home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / FIND.4TH < prev    next >
Text File  |  1994-10-30  |  6KB  |  259 lines
  1. \ FIND PROGRAM, BY TOM ALMY.
  2.  
  3. \ THIS PROGRAM IS COPYRIGHT (C) 1985 BY TOM ALMY,
  4. \ ALL RIGHTS RESERVED.
  5.  
  6. \  Users of ForthCMP are given permission to use or distribute this
  7. \  program, as long as no charge is made and the credit message is maintained.
  8.  
  9.  
  10. 100 MSDOS
  11. INCLUDE DOS1
  12.  
  13. CREATE TIB 128 ALLOT    \ We need to allocate these here
  14. VARIABLE #TIB 
  15. VARIABLE >IN
  16.  
  17. 0 0 IN/OUT NEED HELP-ME
  18.  
  19. \ KEY -- FROM A FILE
  20.  
  21. 32768 CONSTANT INBUFSZ
  22. 128 CONSTANT SCRATCH_BUF
  23. HCB INFILE            \ File being read
  24. 10000 CONSTANT INBUFFER        \ Buffer for input file in high memory
  25. VARIABLE INBUFPTR        \ Pointer to next character in buffer
  26. VARIABLE INBUFEND        \ End of buffer
  27.  
  28. : KEY  
  29.     INBUFPTR @ INBUFEND @ = IF ( fetch block )
  30.     INFILE INBUFFER INBUFSZ FREAD ?DUP IF ( everything OK )
  31.         INBUFFER INBUFPTR !     
  32.         INBUFFER + INBUFEND !
  33.     ELSE 
  34.         [CTRL] Z EXIT 
  35.     THEN
  36.     THEN
  37.     INBUFPTR @ C@ 127 AND
  38.     1 INBUFPTR +! ;
  39.  
  40. \ DIRECTORY SEARCHING STUFF
  41.  
  42. 256 CONSTANT LINBUFSIZE        \ Lines should not be longer than this
  43. CREATE LINEBUF    LINBUFSIZE ALLOT
  44. CREATE MATCHBUF 128 ALLOT 
  45. CREATE UCMATCHBUF 128 ALLOT    \ upcased version of above )
  46. VARIABLE NEXTITEM        \ must scan for new wildcard file name
  47. HCB WILDFILE            \ possibly wildcarded file name
  48. VARIABLE INFILEP        \ just a pointer
  49. VARIABLE /PNTR            \ location of last / or \
  50. 0 VALUE NEWFILE?        \ new file
  51.  
  52. 2 1 IN/OUT
  53. : PROCESS-WORD ( destAddr srcaddr -- newdestaddr )
  54.     BEGIN #TIB @ >IN @ > WHILE   \ more characters to process
  55.         DUP C@ BL = IF DROP EXIT THEN \ found blank -- quit
  56.     DUP C@ [CHAR] \ = IF 1+ 1 >IN +! THEN \ quote next character
  57.         2DUP C@ SWAP C!
  58.         1+ SWAP 1+ SWAP 1 >IN +!
  59.     REPEAT
  60.     DROP \ reached end (bad news), we are finished 
  61. ;
  62.  
  63. 2 2 IN/OUT
  64. : SEEK-START ( destAddr srcAddr -- destAddr newSrcAddr )
  65.     BEGIN #TIB @ >IN @ > WHILE \ more characters to process
  66.         DUP C@ BL = IF  1+  1 >IN +!
  67.             ELSE  EXIT THEN
  68.     REPEAT \ BAD NEWS IF FINISHES
  69. ;      
  70.  
  71.  
  72. 0 1 IN/OUT 
  73. : NICE-WORD ( -- addr )
  74.     DP @  1+ TIB >IN @ +  \ destAddr srcAddr
  75.     SEEK-START
  76.     PROCESS-WORD
  77.     DP @ 1+ - \ length of match string
  78.     DP @ C!     \ gets stored at start
  79.     DP @ 
  80. ;
  81.  
  82.  
  83. 0 0 IN/OUT
  84. : PARSE-COMMAND-LINE  ( -- )
  85.    129 128 C@ >BUFFER
  86.    NEXTITEM ON
  87.    NICE-WORD COUNT DUP 0= IF HELP-ME THEN ( NO ARGUMENTS )
  88.    MATCHBUF SWAP CMOVE    ( MOVE IN MATCH STRING )
  89.    128 0 DO MATCHBUF I + C@ DUP [CHAR] a >= IF DUP [CHAR] z <= 
  90.                           IF 32 - THEN THEN
  91.         UCMATCHBUF I + C! LOOP   ( fill uppercase buffer )
  92.    ;
  93.  
  94.  
  95. 1 0 IN/OUT 
  96. : PUTN ( character -- , put in string of INFILE )
  97.    INFILEP @ C! 1 INFILEP +! ;
  98.  
  99.  
  100. 0 0 IN/OUT
  101. : MAKE-FILENAME \ set up INFILE with path from WILDFILE and
  102.         \ file name from SCRATCH_BUF
  103.     INFILE 3 + INFILEP ! \ address of destination string
  104.     INFILEP @  /PNTR !  \ location of last slash 
  105.     WILDFILE CELL+ COUNT 0 ?DO COUNT DUP PUTN 
  106.          DUP [CHAR] \ = OVER [CHAR] : = OR SWAP [CHAR] / = OR IF 
  107.             INFILEP @ /PNTR ! THEN 
  108.     LOOP
  109.     DROP ( wildfile pointer )
  110.     /PNTR @ INFILEP !    \ get rid of characters after last \
  111.     SCRATCH_BUF 30 + \ remainder of filename
  112.     BEGIN COUNT DUP WHILE PUTN REPEAT 2DROP
  113.     INFILEP @ INFILE 3 + - INFILE 2 + C! \ length
  114.     0 PUTN \ zero delimit string
  115.     ;
  116.  
  117.  
  118. 0 1 IN/OUT 
  119. : NEW-FILE? ( -- success )
  120.   BEGIN NEXTITEM @ IF ( must scan input stream )
  121.     BL WORD DUP C@ 0= IF DROP 0 EXIT THEN ( End of line )
  122.     WILDFILE NAME>HCB
  123.     WILDFILE HCB>N 0 firstf
  124.     NEXTITEM OFF 
  125.       ELSE
  126.     nextf 
  127.       THEN 
  128.     WHILE ( search failed )
  129.       NEXTITEM ON
  130.     REPEAT
  131.   MAKE-FILENAME
  132.   INFILE O_RD FOPEN IF MESSAGES CR 
  133.     ." OPEN FAILED FOR " INFILE .FNAME CONSOLE
  134.     NEW-FILE? EXIT THEN
  135.   INBUFEND @ INBUFPTR !     ( force first read )
  136.   -1 ( SUCCESS! )   ;
  137.  
  138.  
  139. 0 0 IN/OUT
  140. : CLOSE-THE-FILE  INFILE FCLOSE DROP ;
  141.  
  142.  
  143.  
  144. \ Messages
  145.  
  146.  
  147. 0 0 IN/OUT
  148. : PRINT-SEARCHING ( --- )
  149.     NEWFILE? IF
  150.         CR ." Searching " INFILE .FNAME 
  151.         0 TO NEWFILE?
  152.     THEN 
  153. ;
  154.  
  155. 0 0 IN/OUT
  156. : HELLO
  157.     MESSAGES
  158.     ." Search Program.  Copyright (C) 1985 by Tom Almy" CR
  159.     CONSOLE
  160. ;
  161.  
  162. 0 0 IN/OUT
  163. : HELP-ME
  164.     MESSAGES
  165.     ." Usage: FIND string {filenames}" CR
  166.     ." String escape character is \" CR
  167.     bye
  168. ;  
  169.  
  170.  
  171.  
  172.  
  173. \ Searching functions
  174.  
  175.  
  176.  
  177. VARIABLE LINE#
  178.  
  179. VARIABLE ^LINE
  180.  
  181. 0 0 IN/OUT
  182. : CLEAR-LINE   LINEBUF ^LINE ! ;
  183.  
  184. 1 0 IN/OUT 
  185. : PUT-LINE ( char -- ) 
  186.   LINEBUF LINBUFSIZE + ^LINE @ = IF 
  187.     MESSAGES CR ." LINE TOO LONG!" CLEAR-LINE CONSOLE THEN
  188.   ^LINE @ C!  1 ^LINE +! ;
  189.  
  190. 10 CONSTANT aLF
  191. 13 CONSTANT aCR
  192.  9 CONSTANT aTAB
  193.  
  194. 0 0 IN/OUT
  195. : PRINT-TO-EOL
  196.     BEGIN 
  197.     KEY DUP aLF <> OVER [CTRL] Z <> AND 
  198.     WHILE 
  199.     DUP aCR = IF DROP ELSE EMIT THEN
  200.     REPEAT
  201.     DROP ;
  202.  
  203. 0 0 IN/OUT
  204. : SEARCHING   
  205.    -1 TO NEWFILE?
  206.    1 LINE# !
  207.    CLEAR-LINE
  208.    UCMATCHBUF COUNT
  209.    MATCHBUF COUNT  ( first char on top of stack, bufferaddr under )
  210.    BEGIN KEY  CASE
  211.     aLF OF  CLEAR-LINE  2DROP 2DROP            \ lf
  212.          UCMATCHBUF COUNT MATCHBUF COUNT 
  213.          1 LINE# +! ENDOF                 
  214.      \ stack has ucbufaddr char bufaddr char key
  215.     OVER  OF                    \ CHARACTER MATCHES
  216.          PUT-LINE  NIP SWAP COUNT ROT COUNT 
  217.            DUP 0= IF   2DROP 2DROP     \ COMPLETE MATCH       
  218.          PRINT-SEARCHING
  219.          CR  LINE# @ 4 .R SPACE
  220.          LINEBUF ^LINE @ LINEBUF - TYPE
  221.          PRINT-TO-EOL
  222.          CLEAR-LINE  
  223.          UCMATCHBUF COUNT MATCHBUF COUNT THEN     
  224.         ENDOF
  225.      \ stack has ucbufaddr char bufaddr char key
  226.     3 PICK  OF                 \ UPPERCASE CHARACTER MATCHES
  227.          ROT PUT-LINE  DROP SWAP COUNT ROT COUNT 
  228.            DUP 0= IF   2DROP 2DROP     \ COMPLETE MATCH       
  229.          PRINT-SEARCHING
  230.          CR  LINE# @ 4 .R SPACE
  231.          LINEBUF ^LINE @ LINEBUF - TYPE
  232.          PRINT-TO-EOL
  233.          CLEAR-LINE  
  234.          UCMATCHBUF COUNT MATCHBUF COUNT THEN     
  235.         ENDOF
  236.     [CTRL] Z OF  2DROP 2DROP  EXIT ENDOF        \ END OF FILE
  237.     PUT-LINE 2DROP 2DROP                \ NO MATCH
  238.     UCMATCHBUF COUNT MATCHBUF COUNT    0   
  239.      ENDCASE
  240.    AGAIN \ REPEAT FOREVER
  241.    ;
  242.     
  243.  
  244.  
  245. \ MAIN LOOP
  246. : MAIN
  247.     HELLO
  248.     PARSE-COMMAND-LINE
  249.     BEGIN 
  250.     NEW-FILE? WHILE
  251.     SEARCHING 
  252.     CLOSE-THE-FILE
  253.     REPEAT ;
  254.  
  255. INCLUDE DOS2
  256. INCLUDE FORTHLIB
  257. END
  258.  
  259.